home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 / Ham Radio 2000.iso / ham2000 / misc / dspice0s / alter.c < prev    next >
C/C++ Source or Header  |  1992-11-21  |  12KB  |  375 lines
  1. /* alter.f -- translated by f2c (version of 3 February 1990  3:36:42).
  2.    You must link the resulting object file with the libraries:
  3.     -lF77 -lI77 -lm -lc   (in that order)
  4. */
  5.  
  6. #include "f2c.h"
  7.  
  8. /* Common Block Declarations */
  9.  
  10. struct {
  11.     integer ielmnt, isbckt, nsbckt, iunsat, nunsat, itemps, numtem, isens, 
  12.         nsens, ifour, nfour, ifield, icode, idelim, icolum, insize, 
  13.         junode, lsbkpt, numbkp, iorder, jmnode, iur, iuc, ilc, ilr, 
  14.         numoff, isr, nmoffc, iseq, iseq1, neqn, nodevs, ndiag, iswap, 
  15.         iequa, macins, lvnim1, lx0, lvn, lynl, lyu, lyl, lx1, lx2, lx3, 
  16.         lx4, lx5, lx6, lx7, ld0, ld1, ltd, imynl, imvn, lcvn, nsnod, 
  17.         nsmat, nsval, icnod, icmat, icval, loutpt, lpol, lzer, irswpf, 
  18.         irswpr, icswpf, icswpr, irpt, jcpt, irowno, jcolno, nttbr, nttar, 
  19.         lvntmp;
  20. } tabinf_;
  21.  
  22. #define tabinf_1 tabinf_
  23.  
  24. struct {
  25.     integer locate[50], jelcnt[50], nunods, ncnods, numnod, nstop, nut, nlt, 
  26.         nxtrm, ndist, ntlin, ibr, numvs, numalt, numcyc;
  27. } cirdat_;
  28.  
  29. #define cirdat_1 cirdat_
  30.  
  31. struct {
  32.     doublereal atime, aprog[3], adate, atitle[10], defl, defw, defad, defas, 
  33.         rstats[50];
  34.     integer iwidth, lwidth, nopage;
  35. } miscel_;
  36.  
  37. #define miscel_1 miscel_
  38.  
  39. struct {
  40.     doublereal value[200000];
  41. } blank_;
  42.  
  43. #define blank_1 blank_
  44.  
  45. struct {
  46.     doublereal omega, time, delta, delold[7], ag[7], vt, xni, egfet, xmu, 
  47.         sfactr;
  48.     integer mode, modedc, icalc, initf, method, iord, maxord, noncon, iterno, 
  49.         itemno, nosolv, modac, ipiv, ivmflg, ipostp, iscrch, iofile;
  50. } status_;
  51.  
  52. #define status_1 status_
  53.  
  54. /* Table of constant values */
  55.  
  56. static integer c__0 = 0;
  57. static integer c__1 = 1;
  58.  
  59. /*<       subroutine alter >*/
  60. /* Subroutine */ int alter_()
  61. {
  62.     /* Initialized data */
  63.  
  64.     static struct {
  65.     char e_1[32];
  66.     doublereal e_2;
  67.     } equiv_16 = { {'c', 'h', 'a', 'n', 'g', 'e', ' ', 'f', 'o', 'l', 'l',
  68.          'o', 'w', 'i', 'n', 'g', ' ', 'p', 'a', 'r', 'a', 'm', 'e', 
  69.         't', 'e', 'r', 's', ' ', ' ', ' ', ' ', ' '}, 0. };
  70.  
  71. #define chtitl ((doublereal *)&equiv_16)
  72.  
  73.     static integer lnod[50] = { 10,14,16,8,15,16,15,16,13,8,18,38,27,35,8,8,
  74.         35,5,5,5,5,5,5,5,0,0,0,0,0,0,21,21,21,21,21,21,21,21,21,21,8,8,8,
  75.         8,8,0,0,0,0,0 };
  76.     static integer lval[50] = { 5,4,4,2,1,1,1,1,4,4,3,4,4,16,1,1,9,2,1,1,19,
  77.         55,17,46,0,0,0,0,0,0,1,1,1,1,1,17,17,17,17,17,1,1,1,1,1,0,0,0,0,0 
  78.         };
  79.  
  80.     /* Format strings */
  81.     static char fmt_110[] = "(\002********      \002,a8,\002      *******\
  82. *\002)";
  83.     static char fmt_360[] = "(//)";
  84.     static char fmt_401[] = "(\0020*error*:  parameter change failed\002,/\
  85. ,\0020*******:  \002,a8,\002 is not in the original circuit\002)";
  86.  
  87.     /* System generated locals */
  88.     integer i_1, i_2;
  89.  
  90.     /* Builtin functions */
  91.     integer s_wsfe(), do_fio(), e_wsfe();
  92.  
  93.     /* Local variables */
  94.     static integer itab, locv, nogo;
  95.     extern integer xxor_();
  96.     static integer locv1;
  97.     extern /* Subroutine */ int copy8_(), title_(), cpytb4_(), cpytb8_();
  98.     static integer id;
  99. #define nodplc ((integer *)&blank_1)
  100. #define cvalue ((complex *)&blank_1)
  101.     extern logical memptr_();
  102.     extern /* Subroutine */ int clrmem_();
  103.     static integer loc, loc1;
  104.  
  105.     /* Fortran I/O blocks */
  106.     static cilist io__11 = { 0, 0, 0, fmt_110, 0 };
  107.     static cilist io__13 = { 0, 0, 0, fmt_360, 0 };
  108.     static cilist io__14 = { 0, 0, 0, fmt_401, 0 };
  109.  
  110.  
  111. /*<       implicit double precision (a-h,o-z) >*/
  112.  
  113. /*     this routine changes the element or device parameters */
  114.  
  115. /* spice version 2g.6  sccsid=tabinf 3/15/83 */
  116. /*<       common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem, >*/
  117. /*<      1   isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize, >*/
  118. /*<      2   junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr, >*/
  119. /*<      3   nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1, >*/
  120. /*<      4   lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd, >*/
  121. /*<      5   imynl,imvn,lcvn,nsnod,nsmat,nsval,icnod,icmat,icval, >*/
  122. /*<      6   loutpt,lpol,lzer,irswpf,irswpr,icswpf,icswpr,irpt,jcpt, >*/
  123. /*<      7   irowno,jcolno,nttbr,nttar,lvntmp >*/
  124. /* spice version 2g.6  sccsid=cirdat 3/15/83 */
  125. /*<       common /cirdat/ locate(50),jelcnt(50),nunods,ncnods,numnod,nstop, >*/
  126. /*<      1   nut,nlt,nxtrm,ndist,ntlin,ibr,numvs,numalt,numcyc >*/
  127. /* spice version 2g.6  sccsid=miscel 3/15/83 */
  128. /*<       common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad, >*/
  129. /*<      1  defas,rstats(50),iwidth,lwidth,nopage >*/
  130. /* spice version 2g.6  sccsid=blank 3/15/83 */
  131. /*<       common /blank/ value(200000) >*/
  132. /* spice version 2g.6  sccsid=status 3/15/83 */
  133. /*<       common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet, >*/
  134. /*<      1   xmu,sfactr,mode,modedc,icalc,initf,method,iord,maxord,noncon, >*/
  135. /*<      2   iterno,itemno,nosolv,modac,ipiv,ivmflg,ipostp,iscrch,iofile >*/
  136. /*<       integer nodplc(64) >*/
  137. /*<       complex cvalue(32) >*/
  138. /*<       equivalence (value(1),nodplc(1),cvalue(1)) >*/
  139. /*<       logical memptr >*/
  140.  
  141. /*<       integer xxor >*/
  142. /*<       dimension lnod(50),lval(50) >*/
  143. /*<       dimension chtitl(4) >*/
  144. /*<       data chtitl / 8hchange f,8hollowing,8h paramet,8hers     / >*/
  145. /*<       data lnod /10,14,16, 8,15,16,15,16,13, 8, >*/
  146. /*<      1           18,38,27,35, 8, 8,35, 5, 5, 5, >*/
  147. /*<      2            5, 5, 5, 5, 0, 0, 0, 0, 0, 0, >*/
  148. /*<      3           21,21,21,21,21,21,21,21,21,21, >*/
  149. /*<      4            8, 8, 8, 8, 8, 0, 0, 0, 0, 0 / >*/
  150. /*<       data lval / 5, 4, 4, 2, 1, 1, 1, 1, 4, 4, >*/
  151. /*<      1            3, 4, 4,16, 1, 1, 9, 2, 1, 1, >*/
  152. /*<      2           19,55,17,46, 0, 0, 0, 0, 0, 0, >*/
  153. /*<      3            1, 1, 1, 1, 1,17,17,17,17,17, >*/
  154. /*<      4            1, 1, 1, 1, 1, 0, 0, 0, 0, 0 / >*/
  155.  
  156. /*<       call title (0,lwidth,1,chtitl) >*/
  157.     title_(&c__0, &miscel_1.lwidth, &c__1, chtitl);
  158. /*<       do 350 id=1,24 >*/
  159.     for (id = 1; id <= 24; ++id) {
  160. /*<       loc=locate(id) >*/
  161.     loc = cirdat_1.locate[id - 1];
  162. /*<    10 if (loc.eq.0) go to 350 >*/
  163. L10:
  164.     if (loc == 0) {
  165.         goto L350;
  166.     }
  167. /*<       if (nodplc(loc+lnod(id)-2).ne.numcyc) go to 300 >*/
  168.     if (nodplc[loc + lnod[id - 1] - 3] != cirdat_1.numcyc) {
  169.         goto L300;
  170.     }
  171. /*<       locv=nodplc(loc+1) >*/
  172.     locv = nodplc[loc];
  173. /*<       loc1=locate(id) >*/
  174.     loc1 = cirdat_1.locate[id - 1];
  175. /*<    50 if (loc1.eq.0) go to 400 >*/
  176. L50:
  177.     if (loc1 == 0) {
  178.         goto L400;
  179.     }
  180. /*<       if (nodplc(loc1+lnod(id)-2).ne.0) go to 400 >*/
  181.     if (nodplc[loc1 + lnod[id - 1] - 3] != 0) {
  182.         goto L400;
  183.     }
  184. /*<       locv1=nodplc(loc1+1) >*/
  185.     locv1 = nodplc[loc1];
  186. /*<       if (xxor(value(locv),value(locv1)).eq.0) go to 100 >*/
  187.     if (xxor_(&blank_1.value[locv - 1], &blank_1.value[locv1 - 1]) == 0) {
  188.  
  189.         goto L100;
  190.     }
  191. /*<       loc1=nodplc(loc1) >*/
  192.     loc1 = nodplc[loc1 - 1];
  193. /*<       go to 50 >*/
  194.     goto L50;
  195.  
  196. /*  copy changed values to the original tables */
  197.  
  198. /*  copy real part */
  199.  
  200. /*<   100 call copy8(value(locv),value(locv1),lval(id)) >*/
  201. L100:
  202.     copy8_(&blank_1.value[locv - 1], &blank_1.value[locv1 - 1], &lval[id 
  203.         - 1]);
  204. /*<       write (iofile,110) value(locv1) >*/
  205.     io__11.ciunit = status_1.iofile;
  206.     s_wsfe(&io__11);
  207.     do_fio(&c__1, (char *)&blank_1.value[locv1 - 1], (ftnlen)sizeof(
  208.         doublereal));
  209.     e_wsfe();
  210. /*<   110 format ('********      ',a8,'      ********') >*/
  211.  
  212. /*  treat non-node tables specially */
  213.  
  214. /*<   200 if (id.ge.11) go to 300 >*/
  215. /* L200: */
  216.     if (id >= 11) {
  217.         goto L300;
  218.     }
  219. /*<       go to (300,210,220,300,230,240,230,240,260,260), id >*/
  220.     switch (id) {
  221.         case 1:  goto L300;
  222.         case 2:  goto L210;
  223.         case 3:  goto L220;
  224.         case 4:  goto L300;
  225.         case 5:  goto L230;
  226.         case 6:  goto L240;
  227.         case 7:  goto L230;
  228.         case 8:  goto L240;
  229.         case 9:  goto L260;
  230.         case 10:  goto L260;
  231.     }
  232. /*<   210 if (nodplc(loc+4).eq.1) go to 300 >*/
  233. L210:
  234.     if (nodplc[loc + 3] == 1) {
  235.         goto L300;
  236.     }
  237. /*<       if (memptr(nodplc(loc1+7))) call clrmem(nodplc(loc1+7)) >*/
  238.     if (memptr_(&nodplc[loc1 + 6])) {
  239.         clrmem_(&nodplc[loc1 + 6]);
  240.     }
  241. /*<       call cpytb8(loc+7,loc1+7) >*/
  242.     i_1 = loc + 7;
  243.     i_2 = loc1 + 7;
  244.     cpytb8_(&i_1, &i_2);
  245. /*<       go to 300 >*/
  246.     goto L300;
  247. /*<   220 if (nodplc(loc+4).eq.1) go to 300 >*/
  248. L220:
  249.     if (nodplc[loc + 3] == 1) {
  250.         goto L300;
  251.     }
  252. /*<       if (memptr(nodplc(loc1+10))) call clrmem(nodplc(loc1+10)) >*/
  253.     if (memptr_(&nodplc[loc1 + 9])) {
  254.         clrmem_(&nodplc[loc1 + 9]);
  255.     }
  256. /*<       call cpytb8(loc+10,loc1+10) >*/
  257.     i_1 = loc + 10;
  258.     i_2 = loc1 + 10;
  259.     cpytb8_(&i_1, &i_2);
  260. /*<       go to 300 >*/
  261.     goto L300;
  262. /*<   230 itab=5 >*/
  263. L230:
  264.     itab = 5;
  265. /*<       go to 250 >*/
  266.     goto L250;
  267. /*<   240 itab=6 >*/
  268. L240:
  269.     itab = 6;
  270. /*<   250 if (id.le.6) go to 255 >*/
  271. L250:
  272.     if (id <= 6) {
  273.         goto L255;
  274.     }
  275. /*<       if (memptr(nodplc(loc1+itab+1))) call clrmem(nodplc(loc1+itab+1)) >*/
  276.     if (memptr_(&nodplc[loc1 + itab])) {
  277.         clrmem_(&nodplc[loc1 + itab]);
  278.     }
  279. /*<       call cpytb4(loc+itab+1,loc1+itab+1) >*/
  280.     i_1 = loc + itab + 1;
  281.     i_2 = loc1 + itab + 1;
  282.     cpytb4_(&i_1, &i_2);
  283. /*<   255 if (memptr(nodplc(loc1+itab+2))) call clrmem(nodplc(loc1+itab+2)) >*/
  284. L255:
  285.     if (memptr_(&nodplc[loc1 + itab + 1])) {
  286.         clrmem_(&nodplc[loc1 + itab + 1]);
  287.     }
  288. /*<       call cpytb4(loc+itab+2,loc1+itab+2) >*/
  289.     i_1 = loc + itab + 2;
  290.     i_2 = loc1 + itab + 2;
  291.     cpytb4_(&i_1, &i_2);
  292. /*<       if (memptr(nodplc(loc1+itab+3))) call clrmem(nodplc(loc1+itab+3)) >*/
  293.     if (memptr_(&nodplc[loc1 + itab + 2])) {
  294.         clrmem_(&nodplc[loc1 + itab + 2]);
  295.     }
  296. /*<       call cpytb8(loc+itab+3,loc1+itab+3) >*/
  297.     i_1 = loc + itab + 3;
  298.     i_2 = loc1 + itab + 3;
  299.     cpytb8_(&i_1, &i_2);
  300. /*<       if (memptr(nodplc(loc1+itab+4))) call clrmem(nodplc(loc1+itab+4)) >*/
  301.     if (memptr_(&nodplc[loc1 + itab + 3])) {
  302.         clrmem_(&nodplc[loc1 + itab + 3]);
  303.     }
  304. /*<       call cpytb8(loc+itab+4,loc1+itab+4) >*/
  305.     i_1 = loc + itab + 4;
  306.     i_2 = loc1 + itab + 4;
  307.     cpytb8_(&i_1, &i_2);
  308. /*<       if (memptr(nodplc(loc1+itab+5))) call clrmem(nodplc(loc1+itab+5)) >*/
  309.     if (memptr_(&nodplc[loc1 + itab + 4])) {
  310.         clrmem_(&nodplc[loc1 + itab + 4]);
  311.     }
  312. /*<       call cpytb4(loc+itab+5,loc1+itab+5) >*/
  313.     i_1 = loc + itab + 5;
  314.     i_2 = loc1 + itab + 5;
  315.     cpytb4_(&i_1, &i_2);
  316. /*<       if (memptr(nodplc(loc1+itab+6))) call clrmem(nodplc(loc1+itab+6)) >*/
  317.     if (memptr_(&nodplc[loc1 + itab + 5])) {
  318.         clrmem_(&nodplc[loc1 + itab + 5]);
  319.     }
  320. /*<       call cpytb8(loc+itab+6,loc1+itab+6) >*/
  321.     i_1 = loc + itab + 6;
  322.     i_2 = loc1 + itab + 6;
  323.     cpytb8_(&i_1, &i_2);
  324. /*<       go to 300 >*/
  325.     goto L300;
  326. /*<   260 if (memptr(nodplc(loc1+5))) call clrmem(nodplc(loc1+5)) >*/
  327. L260:
  328.     if (memptr_(&nodplc[loc1 + 4])) {
  329.         clrmem_(&nodplc[loc1 + 4]);
  330.     }
  331. /*<       call cpytb8(loc+5,loc1+5) >*/
  332.     i_1 = loc + 5;
  333.     i_2 = loc1 + 5;
  334.     cpytb8_(&i_1, &i_2);
  335.  
  336. /*<   300 loc=nodplc(loc) >*/
  337. L300:
  338.     loc = nodplc[loc - 1];
  339. /*<       go to 10 >*/
  340.     goto L10;
  341. /*<   350 continue >*/
  342. L350:
  343.     ;}
  344. /*<       write (iofile,360) >*/
  345.     io__13.ciunit = status_1.iofile;
  346.     s_wsfe(&io__13);
  347.     e_wsfe();
  348. /*<   360 format (//) >*/
  349. /*<       go to 500 >*/
  350.     goto L500;
  351.  
  352. /*<   400 write (iofile,401) value(nodplc(loc1+1)) >*/
  353. L400:
  354.     io__14.ciunit = status_1.iofile;
  355.     s_wsfe(&io__14);
  356.     do_fio(&c__1, (char *)&blank_1.value[nodplc[loc1] - 1], (ftnlen)sizeof(
  357.         doublereal));
  358.     e_wsfe();
  359. /*<   401 format ('0*error*:  parameter change failed',/, >*/
  360. /*<      1        '0*******:  ',a8,' is not in the original circuit') >*/
  361. /*<       nogo=1 >*/
  362.     nogo = 1;
  363.  
  364. /*<   500 return >*/
  365. L500:
  366.     return 0;
  367. /*<       end >*/
  368. } /* alter_ */
  369.  
  370. #undef cvalue
  371. #undef nodplc
  372. #undef chtitl
  373.  
  374.  
  375.